home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Smlperv.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  7.2 KB  |  275 lines  |  [TEXT/R*ch]
  1. (* Initialization of built-in units *)
  2.  
  3. open List Fnlib Const Smlexc Prim Smlprim Globals Units Types;
  4.  
  5. (* --- Global infix basis --- *)
  6.  
  7. val std_infix_basis =
  8. [
  9.    ("before", INFIXst 0),
  10.    ("o",   INFIXst 3),    (":=",  INFIXst 3),
  11.    ("=",   INFIXst 4),    ("<>",  INFIXst 4),
  12.    ("<",   INFIXst 4),    (">",   INFIXst 4),
  13.    ("<=",  INFIXst 4),    (">=",  INFIXst 4),
  14.    ("@",   INFIXRst 5),   ("::",  INFIXRst 5),
  15.    ("+",   INFIXst 6),    ("-",   INFIXst 6),
  16.    ("^",   INFIXst 6),
  17.    ("div", INFIXst 7),    ("mod", INFIXst 7),
  18.    ("*",   INFIXst 7),    ("/",   INFIXst 7)
  19. ];
  20.  
  21. val () =
  22.   app
  23.     (fn(id, status) =>
  24.       Hasht.insert pervasiveInfixTable id status)
  25.     std_infix_basis
  26. ;
  27.  
  28. (* --- Initial constructor basis --- *)
  29.  
  30. val infoFalse = hd(initial_bool_CE)
  31. and infoTrue  = hd(tl initial_bool_CE)
  32. and infoNil   = hd(initial_list_CE)
  33. and infoCons  = hd(tl initial_list_CE)
  34. and infoNONE  = hd(initial_option_CE)
  35. and infoSOME  = hd(tl initial_option_CE)
  36. and infoLESS  = hd(initial_order_CE)
  37. and infoEQUAL = hd(tl initial_order_CE)
  38. and infoGREATER = hd(tl (tl initial_order_CE))
  39. and infoQUOTE      = hd(initial_frag_CE)
  40. and infoANTIQUOTE  = hd(tl initial_frag_CE)
  41. ;
  42.  
  43. val initial_prim_basis =
  44. [
  45.    ("/",       (1, MLPdiv_real)),
  46.    ("floor",   (1, MLPccall(1, "sml_floor"))),
  47.    ("ceil",    (1, MLPccall(1, "sml_ceil"))),
  48.    ("trunc",   (1, MLPccall(1, "sml_trunc"))),
  49.    ("round",   (1, MLPccall(1, "sml_round"))),
  50.    ("real",    (1, MLPprim(1, Pfloatprim Pfloatofint))),
  51.    ("^",       (1, MLPconcat)),
  52.    ("size",    (1, MLPprim(1, Pstringlength))),
  53.    ("!",       (1, MLPprim(1, Pfield 0))),
  54.    (":=",      (1, MLPsetref)),
  55.    ("not",     (1, MLPprim(1, Pnot))),
  56.    ("ignore",  (1, MLPprim(1, Patom 0)))
  57. ];
  58.  
  59. val initial_con_basis =
  60. [
  61.    (* --- Constructors --- *)
  62.    ("false",     CONname (#info infoFalse)),
  63.    ("true",      CONname (#info infoTrue)),
  64.    ("nil",       CONname (#info infoNil)),
  65.    ("::",        CONname (#info infoCons)),
  66.    ("NONE",      CONname (#info infoNONE)),
  67.    ("SOME",      CONname (#info infoSOME)),
  68.    ("LESS",      CONname (#info infoLESS)),
  69.    ("EQUAL",     CONname (#info infoEQUAL)),
  70.    ("GREATER",   CONname (#info infoGREATER)),
  71.    ("QUOTE",     CONname (#info infoQUOTE)),
  72.    ("ANTIQUOTE", CONname (#info infoANTIQUOTE)),
  73.    ("ref",   REFname),
  74.    (* --- Overloaded operators --- *)
  75.    ("=",     VARname OVL2EEBo),
  76.    ("<>",    VARname OVL2EEBo),
  77.    ("~",     VARname OVL1NNo),
  78.    ("abs",   VARname OVL1NNo),
  79.    ("+",     VARname OVL2NNNo),
  80.    ("-",     VARname OVL2NNNo),
  81.    ("*",     VARname OVL2NNNo),
  82.    ("div",   VARname OVL2NNNo),
  83.    ("mod",   VARname OVL2NNNo),
  84.    ("<",     VARname OVL2NNBo),
  85.    (">",     VARname OVL2NNBo),
  86.    ("<=",    VARname OVL2NNBo),
  87.    (">=",    VARname OVL2NNBo),
  88.    ("makestring", VARname OVL1NSo)
  89. ];
  90.  
  91. (* *** Initial static environments *** *)
  92.  
  93. (* Typing variable environment *)
  94.  
  95. val sc_bool =
  96.   trivial_scheme type_bool
  97. and sc_ii_i = trivial_scheme
  98.   (type_arrow (type_pair type_int type_int) type_int)
  99. and sc_r_r = trivial_scheme
  100.   (type_arrow type_real type_real)
  101. and sc_s_i = trivial_scheme
  102.   (type_arrow type_string type_int)
  103. and sc_ss_s = trivial_scheme
  104.   (type_arrow (type_pair type_string type_string) type_string)
  105. and sc_exn =
  106.   trivial_scheme type_exn
  107. ;
  108.  
  109. fun VEofCE (CE : ConEnv) =
  110.   map (fn ci => (#id(#qualid ci), #conType(! (#info ci)))) CE
  111. ;
  112.  
  113. val initial_eq_VE =
  114. [
  115.   ("=", scheme_1u_eq (fn a =>
  116.      type_arrow (type_pair a a) type_bool)),
  117.   ("<>", scheme_1u_eq (fn a =>
  118.      type_arrow (type_pair a a) type_bool))
  119. ];
  120.  
  121. val initial_int_VE =
  122. [
  123. ];
  124.  
  125. val initial_real_VE =
  126. [
  127.   ("/",      trivial_scheme
  128.                (type_arrow (type_pair type_real type_real) type_real)),
  129.   ("floor",  trivial_scheme (type_arrow type_real type_int)),
  130.   ("ceil",   trivial_scheme (type_arrow type_real type_int)),
  131.   ("trunc",  trivial_scheme (type_arrow type_real type_int)),
  132.   ("round",  trivial_scheme (type_arrow type_real type_int)),
  133.   ("real",   trivial_scheme (type_arrow type_int type_real))
  134. ];
  135.  
  136. val initial_string_VE =
  137. [
  138.   ("^",    sc_ss_s),
  139.   ("size", sc_s_i)
  140. ];
  141.  
  142. val initial_ref_VE =
  143. [
  144.   ("ref", scheme_1u_imp (fn a =>
  145.      type_arrow a (type_ref a))),
  146.   ("!", scheme_1u (fn a =>
  147.      type_arrow (type_ref a) a)),
  148.   (":=", scheme_1u (fn a =>
  149.      type_arrow (type_pair (type_ref a) a) type_unit))
  150. ];
  151.  
  152. val sml_initial_VE = concat
  153. [
  154.   VEofCE initial_bool_CE,
  155.   initial_int_VE,
  156.   initial_real_VE,
  157.   initial_string_VE,
  158.   VEofCE initial_list_CE,
  159.   VEofCE initial_option_CE,
  160.   VEofCE initial_order_CE,
  161.   VEofCE initial_frag_CE,
  162.   initial_ref_VE,
  163.   [("not", trivial_scheme(type_arrow type_bool type_bool))],
  164.   [("ignore", scheme_1u (fn a => type_arrow a type_unit))]
  165. ];
  166.  
  167. val sml_initial_TE =
  168. [
  169.    ("unit",      tyname_unit),
  170.    ("bool",      tyname_bool),
  171.    ("int",       tyname_int),
  172.    ("syserror",  tyname_syserror),
  173.    ("word",      tyname_word),
  174.    ("word8",     tyname_word8),
  175.    ("char",      tyname_char),
  176.    ("real",      tyname_real),
  177.    ("string",    tyname_string),
  178.    ("substring", tyname_substring),
  179.    ("list",      tyname_list),
  180.    ("vector",    tyname_vector),
  181.    ("option",    tyname_option),
  182.    ("order",     tyname_order),
  183.    ("frag",      tyname_frag),
  184.    ("ref",       tyname_ref),
  185.    ("exn",       tyname_exn),
  186.    ("ppstream",  tyname_ppstream)
  187. ];
  188.  
  189. val generalExceptions =
  190. [ ("Io", 1, trivial_scheme(type_arrow type_of_io_exn type_exn))
  191. ];
  192.  
  193. fun mkEmptyInfixBasis() =
  194.     (Hasht.new 23 : (string, InfixStatus) Hasht.t)
  195. ;
  196.  
  197. val () =
  198.   app (fn (id, (arity,prim)) =>
  199.          Hasht.insert
  200.            (#uConBasis unit_General) id
  201.            { qualid={qual="General", id=id},
  202.              info=PRIMname (mkPrimInfo arity prim) })
  203.       initial_prim_basis
  204. ;
  205.  
  206. val () =
  207.   app (fn (id, ci) =>
  208.          Hasht.insert
  209.            (#uConBasis unit_General) id
  210.            { qualid={qual="General", id=id}, info=ci })
  211.       initial_con_basis
  212. ;
  213.  
  214. val () =
  215.   app (fn (id, sc) =>
  216.          Hasht.insert (#uVarEnv unit_General) id sc)
  217.       sml_initial_VE
  218. ;
  219.  
  220. val () =
  221.   app (fn (id, tn) =>
  222.          Hasht.insert (#uTyEnv unit_General) id tn)
  223.       sml_initial_TE
  224. ;
  225.  
  226. fun mkEi q arity =
  227.   let val ei = mkExConInfo() in
  228.     setExConArity ei arity;
  229.     setExConTag ei (SOME (q, 0));
  230.     ei
  231.   end;
  232.  
  233. val () =
  234.   app (fn (id, ((q, stamp), arity)) =>
  235.          let val q = {qual="General", id=id} in
  236.            Hasht.insert
  237.              (#uConBasis unit_General) id
  238.              { qualid=q, info=EXNname(mkEi q arity)}
  239.          end)
  240.       predefExceptions
  241. ;
  242.  
  243. val () =
  244.   app (fn (id, arity, sc) =>
  245.          let val q = {qual="General", id=id} in
  246.            Hasht.insert
  247.              (#uConBasis unit_General) id
  248.              { qualid=q, info=EXNname(mkEi q arity)}
  249.          end)
  250.       generalExceptions
  251.  
  252. ;
  253.  
  254. val sc_str_exn = trivial_scheme (type_arrow type_string type_exn);
  255.  
  256. val () =
  257.   app (fn (id, sc) => Hasht.insert (#uVarEnv unit_General) id sc)
  258.       (map (fn (id,             (_, 0)) => (id, sc_exn)
  259.              | (id as "SysErr", (_, 1)) => (id, trivial_scheme
  260.                      (type_arrow type_of_syserror_exn type_exn))
  261.              | (id,             (_, 1)) => (id, sc_str_exn)
  262.              | (_, _) => fatalError "smlperv: ill-defined exception")
  263.        predefExceptions)
  264.  
  265. ;
  266.  
  267. val () =
  268.   app (fn (id, arity, sc) => Hasht.insert (#uVarEnv unit_General) id sc)
  269.       generalExceptions
  270. ;
  271.  
  272. val () =
  273.   Hasht.insert pervSigTable "General" unit_General
  274. ;
  275.